C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C type PFPU = record
C               NAME: integer; (* index into NAMTXT *)
C               NARGS: integer;
C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
C               DTYPE: integer;
C               CHRLEN: integer;
C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
C             end;
 
C type PFEX = record
C               NAME: integer;
C               DTYPE: integer;
C               CHRLEN: integer;
C               NARGS: integer;
C               ARGS: ^(heap) HEAD(PFEXARG);
C               INDARG: ^PFPUARG    (* only for indirect refs *)
C             end;
 
C type PFPUARG = record
C                   DTYPE: integer;
C                   CHLEN: integer;
C                   case STRUC of
C                       var,array: (USAGE: (arg,read,update));
C                       proc: (REF: integer (EXNODE index))
C                       end;
C                   STRUC: (var,array,proc);
C                   SIZE: integer;
C                   DESC: ^(heap) HEAD (PUARGDES);
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   PRNTS: ^(heap) HEAD (LATPAR)
C                end;
 
C type PFEXARG = record
C                   DTYPE: integer;
C                   ATYPE: integer;
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   if (DTYPE=type_char) then
C                       CHMIN,CHMAX: integer
C                   end if
C                 end;
 
C type PFPUDESC = record
C                   NODE: integer (* +ve => index into PUNODE,
C                                    -ve => -index into EXNODE *)
C                 end;
C
C type PFPUCU = record
C                   CBNUM: integer; (* index into CBDATA *)
C                   USAGE: (readonly,update)
C               end;
 
C type PUARGDES = record
C                   TYPE: (direct,indirect);
C                   ANUM: integer;  (* argument number passed out as *)
C                   case TYPE of
C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
C                       indirect: (INUM: integer)   (* arg no. passed to *)
C                       end
C                 end;
 
C type PFPROC = record
C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
C                   ASSOC: integer; (* ditto of associating pu. *)
C                   STMTNO: integer (* statement number of association *)
C               end;
 
C
C type PARENT = record (* routine parent *)
C                   NODE: integer   (* PUNODE index of parent routine *)
C               end;
C
C type APARENT = record (* argument parent *)
C                   NODE: integer;  (* PUNODE index of parent routine *)
C                   ANUM: integer   (* argument number passed down *)
C                end;
 
C type PFUS = record (* unsafe reference check record *)
C               TYPE: 1..5;      (* unsafe reference type *)
C               ASSOC: integer;  (* punode index of calling p.u. *)
C               STMTNO: integer; (* statement number of reference *)
C               EXTRA: integer;  (* type-dependent extra data *)
C               CALLED: integer; (* punode/exnode index of called routine *)
C               ARGNUM: integer  (* argument number for unsafe check *)
C             end;
C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
C ======================================================================
C
C       PFLIB3 Structure Chart:
C       -----------------------
C
C                           +--------+
C                           | PFCONS |
C                           +---+----+
C                               |
C     +-----------+-----------+-+---------+-----------+-----------+
C     |           |           |           |           |           |
C +---+----+  +---+----+  +---+----+  +---+----+  +---+----+  +---+----+
C | PFSETE |  | PFSETR |  | PFSETM |  | PFSETL |  | PFINVO |  | PFSETP |
C +---+----+  +---+----+  +---+----+  +---+----+  +---+----+  +---+----+
C     |           |                       |           |           |
C     |           +------+                |           |           |
C     |                  |            +---+----+  +---+----+  +---+----+
C     +-----------+      |            | PFASLV*|  | PFPROC |  | PFADPA |
C     |           |      |            +--------+  +---+----+  +--------+
C +---+----+  +---+----+ |                            |
C | PFCHK1*|  | PFMERG | |                +-----------+-----------+
C +--------+  +--------+ |                |           |           |
C                        |            +---+----+  +---+----+  +---+----+
C       +----------+-----+-----+      | PFCHK1*|  | PFADPR |  | PFASLV*|
C       |          |           |      +--------+  +--------+  +--------+
C   +---+---+  +---+----+  +---+----+
C   | PFSRD |  | PFSRAD |  | PFSRAP |
C   +-------+  +--------+  +--------+
C
C '*' indicates that the module occurs more than once in the chart.
C This chart does not include routines from PFLIB0 which are called.
C
C ----------------------------------------------------------------------
C
C       P F C O N S   -   Finish construction of PFORT-77 data structure
C
 
        SUBROUTINE PFCONS
 
C
C Move procarg info from ex nodes to pu nodes, and check that
C matching ex & pu nodes are compatible
        CALL PFSETE
C
C Make all links refer to pu nodes instead of ex nodes;
C delete all direct ex-links (they are not processed further).
        CALL PFSETR
C
C Set the main program-unit pointer
        CALL PFSETM
C
C Set the invocation level of all program-units, ignoring the effects of
C procargs
        CALL PFSETL
C
C Invoke program-units to push procargs down the tree, changing the
C invocation level where appropriate
        CALL PFINVO
C
C Setup parent lists
        CALL PFSETP
 
        END
C ----------------------------------------------------------------------
C
C       P F S E T E   -   set external information;
C                           moves proc-arg inf from ex nodes to pu nodes
C                           and does basic external matchup checks.
C
 
        SUBROUTINE PFSETE
 
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER I,P
 
        LOGICAL PFCHK1
        INTEGER PFETOP
 
        DO 100 I=1,NEXTS
            P=PFETOP(I)
            IF (P.GT.0) THEN
                IF (PFCHK1(EXNODE(I),PUNODE(P)))
     +              CALL PFMERG(EXNODE(I),PUNODE(P))
            ELSE IF (P.EQ.0) THEN
                IF (HEAP(EXNODE(I)+1).EQ.-1) THEN
                    CALL PFERR('W: Missing subroutine $N',
     +                         EXNODE(I),0,0,0)
                ELSE
                    CALL PFERR('W: Missing function $N',
     +                         EXNODE(I),0,0,0)
                END IF
            END IF
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       P F C H K 1   -   Reference checking part 1
C
 
        LOGICAL FUNCTION PFCHK1(E,P)
        INTEGER E,P
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER EARG,PARG,ARGNUM
 
        INTEGER LLFIRS,LLNEXT
        LOGICAL ZYXCAS
        EXTERNAL LLFIRS,LLNEXT,ZYXCAS
 
        PFCHK1=.FALSE.
        IF (HEAP(E+1).NE.HEAP(P+6)) THEN
            CALL PFERR(
     +'E: Wrong datatype of subprogram reference to $N',
     +                 E,0,0,0)
        ELSE IF (HEAP(E+2).NE.HEAP(P+7) .AND.
     +           HEAP(E+2).NE.0 .AND.
     +           HEAP(P+7).NE.0) THEN
            CALL PFERR(
     +'E: Wrong character length of function reference to $N',
     +                 E,0,0,0)
            CALL PFERR(' (length is $I, should be $I)',
     +                 HEAP(E+2),HEAP(P+7),0,0)
        ELSE IF (HEAP(E+3).LT.0) THEN
C No further checking if only passed out as an actual argument
            PFCHK1=.TRUE.
        ELSE IF (HEAP(E+3).NE.HEAP(P+1)) THEN
            CALL PFERR(
     +'E: Wrong nu'//'mber of arguments in reference to $N',
     +                 E,0,0,0)
        ELSE IF (HEAP(E+3).EQ.0) THEN
            PFCHK1=.TRUE.
        ELSE
            EARG=LLFIRS(HEAP,HEAP(E+4))
            PARG=LLFIRS(HEAP,HEAP(P+2))
            ARGNUM=1
 100        IF (HEAP(EARG+0).NE.HEAP(PARG+0))
     +      THEN
                CALL PFERR(
     +'E: Argument $I of wrong data-type in reference to $N',
     +                     ARGNUM,E,0,0)
            ELSE IF (.NOT.ZYXCAS(HEAP(PARG+3),
     +                           HEAP(EARG+1))) THEN
                CALL PFERR(
     +'E: Argument $I has the wrong structure in reference to $N',
     +                     ARGNUM,E,0,0)
            ELSE
                EARG=LLNEXT(HEAP,EARG)
                PARG=LLNEXT(HEAP,PARG)
                ARGNUM=ARGNUM+1
                IF (EARG.NE.0) GOTO 100
                PFCHK1=.TRUE.
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F M E R G   -   Merge proc-arg lists from ex node to pu node
C
 
        SUBROUTINE PFMERG(E,P)
        INTEGER E,P
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER EARG,PARG,EPROC
 
        INTEGER LLFIRS,LLNEXT,LLCRHE
        EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLINTO
 
        IF (HEAP(E+3).LE.0) RETURN
        EARG=LLFIRS(HEAP,HEAP(E+4))
        PARG=LLFIRS(HEAP,HEAP(P+2))
 
 100    IF (HEAP(EARG+1).EQ.3 .AND.
     +      HEAP(EARG+2).NE.0) THEN
            IF (HEAP(PARG+6).EQ.0)
     +          HEAP(PARG+6)=LLCRHE(HEAP,0)
 200        EPROC=LLFIRS(HEAP,HEAP(EARG+2))
            IF (EPROC.NE.0) THEN
                CALL LLINTO(HEAP,EPROC,HEAP(PARG+6))
                GOTO 200
            END IF
        END IF
        EARG=LLNEXT(HEAP,EARG)
        PARG=LLNEXT(HEAP,PARG)
        IF (EARG.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F S E T R   -   Set reference information
C                           makes links point to pu nodes not ex nodes
C
 
        SUBROUTINE PFSETR
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER I,TMP,ARG,USREF
 
        INTEGER PFETOP
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,LLDELE
 
        DO 200 I=1,NPUS
            IF (HEAP(PUNODE(I)+5).GT.0) THEN
                CALL PFSRD(HEAP(PUNODE(I)+5))
            END IF
            IF (HEAP(PUNODE(I)+2).NE.0) THEN
                ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
 100            IF (HEAP(ARG+5).NE.0)
     +              CALL PFSRAD(HEAP(ARG+5))
                IF (HEAP(ARG+3).EQ.2 .AND.
     +              HEAP(ARG+6).NE.0)
     +              CALL PFSRAP(HEAP(ARG+6))
                ARG=LLNEXT(HEAP,ARG)
                IF (ARG.NE.0) GOTO 100
            END IF
 200    CONTINUE
 
C Ditto with unsafe references
        USREF=LLFIRS(HEAP,USHEAD)
        IF (USREF.NE.0) THEN
 300        IF (HEAP(USREF+4).LT.0) THEN
                HEAP(USREF+4)=PFETOP(HEAP(USREF+4))
                IF (HEAP(USREF+4).EQ.0) THEN
                    TMP=LLNEXT(HEAP,USREF)
                    CALL LLDELE(HEAP,USREF)
                    USREF=TMP
                ELSE
                    USREF=LLNEXT(HEAP,USREF)
                END IF
            ELSE
                USREF=LLNEXT(HEAP,USREF)
            END IF
            IF (USREF.NE.0) GOTO 300
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F S R D   -   Set reference information: descendents
C
 
        SUBROUTINE PFSRD(LIST)
        INTEGER LIST
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER L,TMP
 
        INTEGER PFETOP
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,LLDELE,LLDELH
 
        L=LLFIRS(HEAP,LIST)
 100    IF (HEAP(L).LT.0) THEN
            HEAP(L)=PFETOP(HEAP(L))
            IF (HEAP(L).EQ.0) THEN
                TMP=LLNEXT(HEAP,L)
                CALL LLDELE(HEAP,L)
                L=TMP
                IF (L.EQ.0) THEN
                    IF (LLFIRS(HEAP,LIST).EQ.0) THEN
                        CALL LLDELH(HEAP,LIST)
                        LIST=0
                    END IF
                END IF
            ELSE
                L=LLNEXT(HEAP,L)
            END IF
        ELSE
            L=LLNEXT(HEAP,L)
        END IF
        IF (L.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F S R A D   -   Set ref info: argument descendents
C
 
        SUBROUTINE PFSRAD(LIST)
        INTEGER LIST
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER L,TMP
 
        INTEGER PFETOP
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,LLDELE,LLDELH
 
        L=LLFIRS(HEAP,LIST)
 100    IF (HEAP(L+2).LT.0) THEN
            HEAP(L+2)=PFETOP(HEAP(L+2))
            IF (HEAP(L+2).EQ.0) THEN
                TMP=LLNEXT(HEAP,L)
                CALL LLDELE(HEAP,L)
                L=TMP
                IF (L.EQ.0) THEN
                    IF (LLFIRS(HEAP,LIST).EQ.0) THEN
                        CALL LLDELH(HEAP,LIST)
                        LIST=0
                    END IF
                END IF
            ELSE
                L=LLNEXT(HEAP,L)
            END IF
        ELSE
            L=LLNEXT(HEAP,L)
        END IF
        IF (L.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F S R A P   -   Set ref into: argument procedures
C
 
        SUBROUTINE PFSRAP(LIST)
        INTEGER LIST
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER L,TMP
 
        INTEGER PFETOP
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,LLDELE,LLDELH
 
        L=LLFIRS(HEAP,LIST)
 100    IF (HEAP(L+0).LT.0) THEN
            HEAP(L+0)=PFETOP(HEAP(L+0))
            IF (HEAP(L+0).EQ.0) THEN
                TMP=LLNEXT(HEAP,L)
                CALL LLDELE(HEAP,L)
                L=TMP
                IF (L.EQ.0) THEN
                    IF (LLFIRS(HEAP,LIST).EQ.0) THEN
                        CALL LLDELH(HEAP,LIST)
                        LIST=0
                    END IF
                END IF
            ELSE
                L=LLNEXT(HEAP,L)
            END IF
        ELSE
            L=LLNEXT(HEAP,L)
        END IF
        IF (L.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F S E T M   -   Set main program-unit
C
 
        SUBROUTINE PFSETM
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER I
 
        MAINND=0
        DO 100 I=1,NPUS
            IF (HEAP(PUNODE(I)+6).EQ.-3) THEN
                IF (MAINND.NE.0) THEN
                    CALL PFERR('F: Two main programs found - $N a'//
     +                         'nd $N',PUNODE(I),PUNODE(MAINND),0,0)
                END IF
                MAINND=I
            END IF
 100    CONTINUE
        IF (MAINND.EQ.0)
     +      CALL PFERR('W: No main program found - analysis may be '//
     +                 'incomplete',0,0,0,0)
 
        END
C ----------------------------------------------------------------------
C
C       P F S E T L   -   Set invocation level of all program-units
C
 
        SUBROUTINE PFSETL
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFPULV/ PULVL
        INTEGER PULVL(500)
        SAVE /PFPULV/
 
        INTEGER I,D,NTOPS,ARG
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,ERROR
 
C
C Step one: set level(non-called routines)=0
C
        DO 100 I=1,NPUS
            PULVL(I)=0
 100    CONTINUE
        DO 300 I=1,NPUS
            IF (HEAP(PUNODE(I)+5).NE.0) THEN
                D=LLFIRS(HEAP,HEAP(PUNODE(I)+5))
 200            IF (HEAP(D).GT.0) PULVL(HEAP(D))=NPUS+1
                D=LLNEXT(HEAP,D)
                IF (D.NE.0) GOTO 200
            END IF
            IF (HEAP(PUNODE(I)+2).NE.0) THEN
                ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
 250            IF (HEAP(ARG+3).EQ.2 .AND.
     +              HEAP(ARG+6).NE.0) THEN
                    D=LLFIRS(HEAP,HEAP(ARG+6))
 275                IF (HEAP(D+0).GT.0)
     +                  PULVL(HEAP(D+0))=NPUS+1
                    D=LLNEXT(HEAP,D)
                    IF (D.NE.0) GOTO 275
                END IF
                ARG=LLNEXT(HEAP,ARG)
                IF (ARG.NE.0) GOTO 250
            END IF
 300    CONTINUE
C
C Step two: count how many apparently top-level routines
C
        NTOPS=0
        DO 400 I=1,NPUS
            IF (PULVL(I).EQ.0) NTOPS=NTOPS+1
 400    CONTINUE
        IF (NPUS.EQ.0) THEN
            CALL ERROR('Fatal Error: No program units')
        ELSE IF (MAINND.EQ.0 .AND. NTOPS.EQ.0) THEN
            CALL ERROR('Fatal Error: Recursive program')
        ELSE IF (NTOPS.EQ.0) THEN
            CALL ERROR('Fatal Internal Error: Recursive main program')
        ELSE IF (NTOPS.GT.1 .AND. MAINND.EQ.0) THEN
            CALL PFERR('W: Incomplete program supplied',0,0,0,0)
        END IF
C
C Step three: If there was a main program, assign levels from it
C             otherwise assign levels from all apparently top-lvl nodes
C
        IF (MAINND.NE.0) THEN
            CALL PFASLV(MAINND,0)
        ELSE
            DO 500 I=1,NPUS
                IF (PULVL(I).EQ.0) CALL PFASLV(I,0)
 500        CONTINUE
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F A S L V   -   Assign an invocation level to a sub-lattice
C
 
        SUBROUTINE PFASLV(N,LVL)
        INTEGER N,LVL
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFPULV/ PULVL
        INTEGER PULVL(500)
        SAVE /PFPULV/
 
        INTEGER STACK(2,500),SP,CUR,I,J,RECERR,MAXRE
        PARAMETER (MAXRE=10)
 
        INTEGER LLNEXT
        EXTERNAL LLNEXT,ERROR,REMARK
 
        PULVL(N)=LVL
        CUR=N
        SP=0
        RECERR=0
C Stack first entry
 100    CONTINUE
C or stack another entry
        IF (SP.GE.500) CALL ERROR('PFASLV: STACK OVERFLOW')
C First check for possible recursion
        DO 150 I=1,SP
            IF (STACK(1,I).EQ.CUR) THEN
                RECERR=RECERR+1
                CALL PFERR('E: Recursive call of $N by $N',
     +                      PUNODE(STACK(1,I)),PUNODE(STACK(1,SP)),0,0)
                IF (I+1.LT.SP)
     +              CALL PFERR(' Via $N',PUNODE(STACK(1,I+1)),0,0,0)
                DO 125 J=I+2,SP-1
                    CALL PFERR(' a'//'nd $N',PUNODE(STACK(1,J)),0,0,0)
 125            CONTINUE
                IF (RECERR.LE.MAXRE) THEN
                    CALL REMARK('Attempting to continue ......')
                    GOTO 200
                END IF
                CALL PFERR('F: Too many recursions found',0,0,0,0)
            END IF
 150    CONTINUE
        SP=SP+1
        STACK(1,SP)=CUR
        STACK(2,SP)=HEAP(PUNODE(CUR)+5)
 
C Proceed to first/next item on descendent list
 200    CONTINUE
        IF (STACK(2,SP).NE.0) STACK(2,SP)=LLNEXT(HEAP,STACK(2,SP))
        IF (STACK(2,SP).EQ.0) THEN
C No more descendents - *POP*
            SP=SP-1
            IF (SP.EQ.0) RETURN
            GOTO 200
        END IF
C Descendent - always traverse (so we detect always detect recursion)
C ... but only set level if new level is higher (i.e. less than)
        CUR=HEAP(STACK(2,SP))
        IF (ABS(PULVL(CUR)).GT.LVL+SP .OR. PULVL(CUR).EQ.0)
     +      PULVL(CUR)=LVL+SP
        GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F I N V O   -   Invoke all subprograms to fill out desc lists
C
 
        SUBROUTINE PFINVO
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFPULV/ PULVL
        INTEGER PULVL(500)
        SAVE /PFPULV/
 
        INTEGER ARG,NC,I
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
 100    CONTINUE
C
C Search for next node to do, node with lowest positive level
C (root levels are zero & processed nodes are negative)
C
        DO 200 I=1,NPUS
            IF (PULVL(I).GT.0) THEN
                NC=I
                GOTO 400
            END IF
 200    CONTINUE
C All done - fix up levels & return
        DO 300 I=1,NPUS
 300        PULVL(I)=ABS(PULVL(I))
        RETURN
 
 400    DO 500 I=NC+1,NPUS
            IF (PULVL(I).GT.0 .AND. PULVL(I).LT.PULVL(NC)) NC=I
 500    CONTINUE
C
C Found the next routine to process
C
        IF (HEAP(PUNODE(NC)+2).NE.0) THEN
C There are arguments - check for procargs
            ARG=LLFIRS(HEAP,HEAP(PUNODE(NC)+2))
            I=1
 600        IF (HEAP(ARG+3).EQ.2) THEN
                CALL PFERR(
     +'D: PFINVO Invoking $N, procargs for argument $I',
     +                     PUNODE(NC),I,0,0)
                CALL PFPROC(NC,ARG)
            END IF
            ARG=LLNEXT(HEAP,ARG)
            I=I+1
            IF (ARG.GT.0) GOTO 600
        END IF
C
C This routine done, mark it as done and do the rest
C
        PULVL(NC)=-PULVL(NC)
        GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F P R O C   -   Process a procarg+argdesc list
C                           --pushes the procarg info down the call tree
C
 
        SUBROUTINE PFPROC(N,ARG)
        INTEGER N,ARG
 
C Arguments:
C ----------
C N == PUNODE index of the program-unit which has a procarg.
C ARG == pointer to PFPUARG record for the dummy procarg in question.
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
        COMMON/PFPULV/ PULVL
        INTEGER PULVL(500)
        SAVE /PFPULV/
 
        INTEGER PROCPX,ADESCX,PROC2P,ARG2,INUM
        LOGICAL OK
 
C Variables:
C ----------
C PROCPX == pointer to PFPROC record representing the actual procarg
C           currently being processed.
C ADESCX == pointer to PUARGDES record, for passing this procarg
C           further down the call tree.
C PROC2P == pointer to PFPROC record representing an actual procarg
C           to which the current procarg (in PROCPX) is being passed
C           as an argument (blech!) - i.e. only used if this dummy
C           procarg is passed out as an actual argument to ANOTHER
C           dummy procarg!
C ARG2 == pointer to PFPUARG record for the dummy procarg to which the
C         current procarg is being passed as an argument.
C INUM == dummy argument number to which this procarg is being passed
C (so we discover INUM from the descendent list (PUARGDES), and from
C  that we work out ARG2 by stepping along the argument list (for PUNODE
C  N) and from that we step through each actual procarg PROC2P
C  associated with the dummy argument ARG2 - which is number INUM).
 
 
        LOGICAL PFCHK1
 
        INTEGER LLFIRS,LLNEXT,LLCRED,LLCRHE
        EXTERNAL LLFIRS,LLNEXT,LLCRED,LLCRHE,LLINTO
 
        IF (HEAP(ARG+6).EQ.0) THEN
            CALL PFERR(
     +'W: No actual procedure args found for $N, analysis incomplete',
     +                 PUNODE(N),0,0,0)
            RETURN
        END IF
 
C For each procedure passed in as an argument ...
        PROCPX=LLFIRS(HEAP,HEAP(ARG+6))
C ... Check to make sure it is compatible
 100    IF (HEAP(PROCPX+0).GT.0) THEN
            IF (HEAP(ARG+2).EQ.0) THEN
C No checking if procedure merely passed further down the tree
                OK=.TRUE.
            ELSE
                OK=PFCHK1(EXNODE(HEAP(ARG+2)),
     +                    PUNODE(HEAP(PROCPX+0)))
            END IF
            IF (OK) THEN
C ... Scan the argument descendent list
                IF (HEAP(ARG+5).NE.0) THEN
                    ADESCX=LLFIRS(HEAP,HEAP(ARG+5))
 200                IF (HEAP(ADESCX+0).EQ.0) THEN
C ... passed to a direct procedure - just add it
                        CALL PFADPR(HEAP(PROCPX+0),
     +                              HEAP(ADESCX+2),
     +                              HEAP(ADESCX+1),
     +                              N)
C ... ... and make us process that node again (new info!)
                        IF (HEAP(ADESCX+2).GT.0)
     +                      PULVL(HEAP(ADESCX+2))=
     +                          ABS(PULVL(HEAP(ADESCX+2)))
                    ELSE
C ... passed to another argument (i.e. indirect procedure)
C     - so add it to all of its procargs.
                        ARG2=LLFIRS(HEAP,HEAP(PUNODE(N)+2))
                        INUM=HEAP(ADESCX+2)
 300                    IF (INUM.GT.1) THEN
                            ARG2=LLNEXT(HEAP,ARG2)
                            INUM=INUM-1
                            GOTO 300
                        END IF
                        PROC2P=LLFIRS(HEAP,HEAP(ARG2+6))
 400                    CALL PFADPR(HEAP(PROCPX+0),
     +                              HEAP(PROC2P+0),
     +                              HEAP(ADESCX+1),
     +                              N)
C ... ... and re-process all these procargs
                        PULVL(HEAP(PROC2P+0))=
     +                      ABS(PULVL(HEAP(PROC2P+0)))
                        PROC2P=LLNEXT(HEAP,PROC2P)
                        IF (PROC2P.NE.0) GOTO 400
                    END IF
                    ADESCX=LLNEXT(HEAP,ADESCX)
                    IF (ADESCX.NE.0) GOTO 200
                END IF
C ... Add this proc to the general descendent list as well
C ... whether it is actually called at this point or not
C <<<FIX THIS LATER>>>
                IF (HEAP(PUNODE(N)+5).EQ.0)
     +              HEAP(PUNODE(N)+5)=LLCRHE(HEAP,0)
                CALL LLINTO(HEAP,
     +                      LLCRED(HEAP,1,HEAP(PROCPX+0)),
     +                      HEAP(PUNODE(N)+5))
C ... And change the invocation level settings as appropriate
                CALL PFASLV(N,ABS(PULVL(N)))
            ELSE
                CALL PFERR(' Incompatible procedure argument "$N"',
     +                     PUNODE(HEAP(PROCPX+0)),0,0,0)
                CALL PFERR(' In reference to $N by $N at statement $I',
     +                     PUNODE(N),PUNODE(HEAP(PROCPX+1)),
     +                     HEAP(PROCPX+2),0)
C Delete incompatible procedure arguments
                PROC2P=LLNEXT(HEAP,PROCPX)
                CALL LLDELE(HEAP,PROCPX)
                PROCPX=PROC2P
                IF (PROCPX.NE.0) GOTO 100
                PROCPX=HEAP(ARG+6)
                IF (LLFIRS(HEAP,PROCPX).EQ.0) THEN
                    CALL LLDELH(HEAP,PROCPX)
                    HEAP(ARG+6)=0
                END IF
                RETURN
            END IF
        END IF
C Advance to the next procedure on the list
        PROCPX=LLNEXT(HEAP,PROCPX)
        IF (PROCPX.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F A D P R   -   Add a procedure to the procarg list
C
 
        SUBROUTINE PFADPR(PX,NX,ARGNUM,AX)
        INTEGER PX,NX,ARGNUM,AX
 
C PX: node number of procedure argument being added
C NX: node number of the program unit it is being added to
C ARGNUM: argument number it is passed down to
C AX: node number of associating program-unit
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
 
        INTEGER ARG,N,TMP(0:3-1)
 
        INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED
        EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLINTO
 
        CALL PFERR('D: PFADPR adding $N as argument $I to $N (from $N)',
     +             PUNODE(PX),ARGNUM,PUNODE(NX),PUNODE(AX))
 
        ARG=LLFIRS(HEAP,HEAP(PUNODE(NX)+2))
        N=1
        TMP(0)=PX
        TMP(1)=AX
        TMP(2)=0
 100    IF (N.LT.ARGNUM) THEN
            ARG=LLNEXT(HEAP,ARG)
            N=N+1
            GOTO 100
        END IF
        IF (HEAP(ARG+6).EQ.0)
     +      HEAP(ARG+6)=LLCRHE(HEAP,0)
        CALL LLINTO(HEAP,LLCRED(HEAP,3,TMP),
     +              HEAP(ARG+6))
 
        END
C ----------------------------------------------------------------------
C
C       P F S E T P   -   Add parent lists to all program-units' desc.s
C
 
        SUBROUTINE PFSETP
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER DESPTR,PARENT(2),X,PNUM,ARG,I,ARGNUM
 
        INTEGER LLFIRS,LLNEXT,LLCRED,LLCRHE
        EXTERNAL LLFIRS,LLNEXT,LLCRED,LLCRHE,LLINTO
 
        DO 600 PNUM=1,NPUS
            PARENT(1+0)=PNUM
            DESPTR=HEAP(PUNODE(PNUM)+5)
            IF (DESPTR.NE.0) THEN
                DESPTR=LLFIRS(HEAP,DESPTR)
 100            IF (HEAP(DESPTR).GT.0) THEN
                    X=PUNODE(HEAP(DESPTR))+4
                    IF (HEAP(X).EQ.0) HEAP(X)=LLCRHE(HEAP,0)
                    CALL LLINTO(HEAP,LLCRED(HEAP,1,PARENT),HEAP(X))
                END IF
                DESPTR=LLNEXT(HEAP,DESPTR)
                IF (DESPTR.NE.0) GOTO 100
            END IF
            IF (HEAP(PUNODE(PNUM)+1).GT.0) THEN
                ARG=LLFIRS(HEAP,HEAP(PUNODE(PNUM)+2))
                ARGNUM=1
 200            IF (HEAP(ARG+5).NE.0) THEN
                    PARENT(1+1)=ARGNUM
                    DESPTR=LLFIRS(HEAP,HEAP(ARG+5))
 300                IF (HEAP(DESPTR+0).EQ.0) THEN
C Argument passed down to a direct reference
                        CALL PFADPA(PARENT,
     +                              HEAP(DESPTR+2),
     +                              HEAP(DESPTR+1))
                    ELSE
C Argument passed down to an indirect reference
                        X=LLFIRS(HEAP,HEAP(PUNODE(PNUM)+2))
                        DO 400 I=2,HEAP(DESPTR+2)
                            X=LLNEXT(HEAP,X)
 400                    CONTINUE
                        X=HEAP(X+6)
                        IF (X.NE.0) THEN
                            X=LLFIRS(HEAP,X)
 500                        CALL PFADPA(PARENT,
     +                                  HEAP(X+0),
     +                                  HEAP(DESPTR+1))
                            X=LLNEXT(HEAP,X)
                            IF (X.NE.0) GOTO 500
                        END IF
                    END IF
                    DESPTR=LLNEXT(HEAP,DESPTR)
                    IF (DESPTR.NE.0) GOTO 300
                END IF
                ARG=LLNEXT(HEAP,ARG)
                ARGNUM=ARGNUM+1
                IF (ARG.NE.0) GOTO 200
            END IF
 600    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       P F A D P A   -   Add parent for argument
C
 
        SUBROUTINE PFADPA(PARENT,N,ARGNUM)
        INTEGER PARENT(2),N,ARGNUM
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER ARG,I
 
        INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED
        EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLINTO
 
        ARG=LLFIRS(HEAP,HEAP(PUNODE(N)+2))
        DO 100 I=2,ARGNUM
            ARG=LLNEXT(HEAP,ARG)
 100    CONTINUE
        IF (HEAP(ARG+7).EQ.0)
     +      HEAP(ARG+7)=LLCRHE(HEAP,0)
        CALL LLINTO(HEAP,LLCRED(HEAP,2,PARENT),
     +              HEAP(ARG+7))
 
        END
